(define (get-value-from-res act l)
    (let ((nl nil)(parl nil))
      (cond ((null act) nil)
	    ((atom act) nil)
	    ((consp act)
	     (cond ((eql (cadr act) '剩余字串) (format t "program logical error.剩余字串 not be permission here.~%"))
		   ((eql (cadr act) '剩余子表) (format t "program logical error.剩余子表 not be permission here.~%"))
		   (t (setf parl (get-func-par-list (car act) l))
		     
		      ;;here need to edit for match diffrent condition.
		      (sset+ nl "(sset+ nl (car res))")
		      (sset+ nl "(setf pos (cadr res)")
		      (sset+ nl "(setf flag (nth 2 res))")))))))
    

(define (assign-from-type-value ft c)
    (cond ((or (null ft)(eql ft 'log)) nil)
	  ((eql ft 'str) (format nil "(sset+ nl (string ~a))" c))
	  ((eql ft 'list)(format nil "(sset+l nl ~a)" (if (consp c) c '(list c))))
	  ((eql ft 'compound) (format nil "(sset+ nl (string ~a))" c))
	  (t (format nil "(apply ~a nl ~a) " ft c))))

(define (get-func-par-list name l)
    (let ((n 0)(nl nil))
    (travel (act-chain l) 'for-child i
	    (if (and (consp i)(eql (car i) name)(> (length i) n))(progn(setf n (length i))(setf nl i))))
    (if nl (cdr nl))))
(define (assign-befor-func name l)
    (let ((nl nil))
      (sset+ nl "(cond ")
      (travel (out-chain name l) 'for-child i
	      (sset+ nl (format nil "(~a ~a)" (cadr i) (eval (read-from-string (format nil "~a-动作宏" (car (cadr i))))))))
      (sset+ nl ")")))
(define (assign-act-func-and-actmacro i l ft)
     (let ((nl nil))
       (if (atom (cadr i)) (progn (sset+ nl (format nil "((~a ~a) "  (cadr i) 'c))
				  (sset+ nl (assign-from-type-value ft 'c))
				  (sset+ nl (format nil "(setf st '~a))" (nth 2 i))))
	   (progn (sset+ nl (format nil "((setf res ~a)" (cadr i)))
		  ;;(sset+ nl (assign-from-type-value ft 'c))
		  ;;下面这一语句如果是超过一个函数调用,需要使用progn变为一个函数调用,这是定义动作宏的一个规则.
		  (sset+ nl (format nil "~a )" (eval (read-from-string (format nil "~a-动作宏" (car (cadr i))))) ))))
     
       nl))

(define (2stage-st-program-all-par l name-list fn res-type &optional test-flag 2-stage)
    (let ((s (cadr name-list))(nl nil)(name (car name-list))(parl (cdr name-list))(n 0))
        
      (sset+ nl (format nil "(define ~a " name-list))
      (sset+ nl "(let ((st '始)(c nil)(nl nil)(res nil)(n 0))")
      (if (member 'n parl) (setf n 1))
      (if (out-chain '前置 l) (sset+ nl (assign-befor-func  '前置 l)))
      (if 2-stage (progn
		    (sset+ nl (format nil "(define (~a-递归 " name))
		    (travel parl 'for-child i
			    (cond ((eql i 'n) (setf n 1))
				  (t nil))
			    (sset+ nl (format nil "~a " i)))
		    (sset+ nl ")(let ((c nil))")
		    (if (out-chain '递归前置 l) (sset+ nl (assign-befor-func '递归前置 l)))))
      (if (or (null n)(= n 0)) (sset+ nl (format nil "(block tr-str (travel ~a 'for-index i (setf c (~a ~a  i)) " s fn s))
	  (sset+ nl (format nil "(block tr-str (travel ~a 'for-index i (setf c (~a ~a (+ n i))) " s fn s)))
      (if test-flag (progn (sset+ nl (format nil "(format t \"~a" name))(sset+ nl "[~a][~a]~%\"  st c)")))
 
      (sset+ nl (2stage-get-status-cond name 'c l res-type 2-stage))
	    
      (sset+ nl (2stage-get-res-cond l res-type name test-flag))
      (if 2-stage (progn (sset+ nl (format nil "(~a-递归 " name))
			 (travel parl 'for-child i
				 (sset+ nl (format nil "~a " i)))
			 (sset+ nl ")))")))
      nl))


(define (2stage-get-res-cond l &optional ft name test-flag)
    (let ((nl nil)(res-method nil))
	  
      (if test-flag (progn (sset+ nl (format nil "(format t \"~a" name))(sset+ nl "<st=\~a><res=\~a>~%\" st res)")))
      (sset+ nl "(if ")
      (if (= (length (in-chain '终 l)) 1)
	  (if (eql (car (car (in-chain '终 l))) '返回值)
	      (progn (sset+ nl "(eql st '返回值) ")
		     (cond ((or (null ft) (eql ft 'log)) (sset+ nl (format nil "(~a res) nil)))" (cadr (car (in-chain '终 l))))))
			   ((eql ft 'compound) (sset+ nl (format nil "~a nil)))" (cadr (car (out-chain '后置 (in-chain '终 l)))))))
			   (t (sset+ nl "nl nil)))"))))
	      (progn  (sset+ nl (format nil "(eql st '~a)" (car (car (in-chain '终 l)))))
		      (cond ((or (null ft) (eql ft 'log)) (sset+ nl " st "))
			    ((eql ft 'compound) (sset+ nl (format nil "~a " (cadr (car (out-chain '后置 (in-chain '终 l)))))))
			    (t (sset+ nl " nl ")))
		      (sset+ nl "nil )))")))
	  (progn (sset+ nl "(or ")
		 (travel (in-chain '终 l) 'for-child i
			 (if (eql (car i) '返回值) (setf res-method (cadr i))
			     (sset+ nl (format nil "(eql st '~a)" (car i)))))
		 (cond ((or (null ft) (eql ft 'log)) (sset+ nl ") st "))
		       ((eql ft 'compound) (sset+ nl (format nil ") ~a " (cadr (car (out-chain '后置 (in-chain '终 l)))))))
		       (t (sset+ nl ") nl ")))
		 (if res-method (progn (sset+ nl "(if (eql st '返回值) ")
				       (cond ((or (null ft) (eql ft 'log)) (sset+ nl (format nil "(~a res) nil))))" res-method )))
					     ((eql ft 'compound) (sset+ nl (format nil "~a nil)))) " (cadr (car (out-chain '后置 (in-chain '终 l)))))))
					     (t (sset+ nl "nl nil))))"))))
		     (sset+ nl "nil )))"))))))
     
		    
(define (2stage-get-status-cond name c l &optional ft 2-stage)
    (let ((nl nil)(act-fn nil)(act-c nil)(end-flag nil)(other-flag nil))
      (sset+ nl "(cond ")
      (travel  (status-chain l) 'for-child i
	       (cond ((eql i '终) (setf end-flag 1))
		     ((eql i '前置) (setf end-flag 1))
		     ((eql i '递归前置) (setf end-flag 1))
		     ((eql i '后置) (setf end-flag 1))
		     ((eql i '递归后置) (setf end-flag 1))
		     ((eql i '返回值) (setf end-flag 1))
		     (t (progn (sset+ nl (format nil "((eql st '~a) " i))
			       (if (and (= (length (out-chain i l)) 1)(eql (nth 2 (car (out-chain i l))) '终))
				   (sset+ nl "st )")
				   (progn (sset+ nl "(cond ")
					  (travel (out-chain i l) 'for-child j
						 
						  (cond  ((eql (cadr j) '读其他)  (setf other-flag 1))
							 ((and (consp (cadr j))(= (length (cadr j)) 2)(eql (cadr (cadr j)) '剩余字串)(eql (nth 2 j) '返回值))
							  (sset+ nl (format nil "((setf res (~a ~a)) (setf res (返回值转换 st res))(setf st '返回值)(return-from tr-str st))" (car (cadr j)) (eval 剩余字串))))
							 ((and (consp (cadr j))(eql (nth 2 j) '返回值))
							  (sset+ nl (format nil "((setf res ~a) ~a"  (cadr j) (eval (read-from-string (format nil "~a-动作宏" (car (cadr j)))))))
							  
							  (sset+ nl "(return-from tr-str st))"))
							
							 (t (sset+ nl (assign-act-func-and-actmacro  j l ft)))))
					  (sset+ nl (format nil "(t (return-from ~a nil))))" name))))))))
      (sset+ nl (format nil "(t (return-from ~a nil)))))" name))))

(define (create-2st f &optional test-flag)
    (let ((ll nil)(r nil))
    (setf ll (read-st-file f))
  ;(default-act-func (act-chain ll))
  ;(setf r (chain-check ll))
  (setf r nil)
  (if (null r) (progn   (setf l (read-from-string
				 (if test-flag
				     (2stage-st-program-all-par ll (list f 's)  'elt 'log 'test '2stage)
				     (2stage-st-program-all-par ll (list f 's)  'elt 'log nil '2stage))))
			(eval l)
			(write-list l (format nil "~a.lisp" f))
			(setf example-list nil)
			)
      (format t "[~a.st] file has error,please check it:~%~a" f r))))


 
(define (create-st-no2 f &optional test-flag)
	(let ((ll nil)(r nil))
		(if (atom f) (setf fn f)
			(if (consp f) (setf fn (car f))))
		(setf ll (read-st-file fn))	
		(setf l (read-from-string (if test-flag
						(2stage-st-program-all-par ll f  'elt 'compound 'test)
						(2stage-st-program-all-par ll f  'elt 'compound  nil))))
		(eval l)
		(write-list l (format nil "~a.lisp" fn))
		(setf example-list nil)))


								    
	      















    
